home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 May: Tool Chest / Developer CD Series May 1996 (Tool Chest) (Apple Computer) (1996).iso / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / User Contributions / AE_Suspend_&_Resume.lisp < prev    next >
Encoding:
Text File  |  1994-06-16  |  12.3 KB  |  251 lines  |  [TEXT/CCL2]
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;;;;
  3. ;;;; Suspending and Resuming Apple Events
  4. ;;;;
  5. ;;;; Dan S. Camper
  6. ;;;;
  7. ;;;; There are times when you don't want to immediately handle an incoming Apple Event but would
  8. ;;;; rather defer its reply until you've obtained some further piece of information to stick into the
  9. ;;;; reply.  Normally, Apple Events must be completely handled within one "program loop cycle" (ie,
  10. ;;;; no functional breaks between the Apple Event manager calling MCL and the population of the
  11. ;;;; Apple Event reply).  However, if you need information that is stored on another system and you
  12. ;;;; cannot retrieve it within that single function call then you'll have to suspend the Apple Event
  13. ;;;; to prevent the Apple Event Manager from sending the (dataless) reply anyway.  I wrote these
  14. ;;;; functions for precisely that reason:  Data that would be stashed into an Apple Event reply was
  15. ;;;; being obtained from a VAX via the Comm Toolbox; I had no way of knowing when I would actually
  16. ;;;; receive the data, and I had to cycle through my main event loop in order to idle the Comm Toolbox
  17. ;;;; tools and handle other requests.
  18. ;;;;
  19. ;;;; MCL bypasses the Apple Event dispatching mechanism and, incidentally, suspends (almost) every single
  20. ;;;; event it gets anyway.  The only events that are not suspended are 1) events that MCL sends to itself,
  21. ;;;; and 2) events that arrive while MCL is *sending* an event somewhere else.  These changes leverage off
  22. ;;;; that behavior by simply preventing MCL from automatically resuming an Apple Event after the handler
  23. ;;;; call is completed.
  24. ;;;;
  25. ;;;; The basic change is this:  If you want to suspend an Apple Event then simply return :suspend from your
  26. ;;;; Apple Event handler.  This return value will prevent MCL from resuming the Apple Event and it will store
  27. ;;;; the event and its reply onto a separate stack, pending eventual resuming.  Before suspending the event
  28. ;;;; you should obtain the "reference number" for the event (actually just the address of the Apple Event
  29. ;;;; record) and store it somewhere so you can later retrieve the event records and resume processing.
  30. ;;;;
  31. ;;;; Two other changes to MCL's Apple Event handling were also made here:  1) If multiple Apple Events are
  32. ;;;; internally queued for their initial passing to handlers, only one event at a time is sent off for processing
  33. ;;;; (previously all the events were called); and 2) the #$keyErrorNumber parameter in the reply record is
  34. ;;;; set only if the parameter didn't exist before -- this allows your handler to use this parameter without MCL
  35. ;;;; overriding the value later.
  36. ;;;;
  37. ;;;; Since three functions here are initially defined in MCL's kernel then you may want to evaluate these contents
  38. ;;;; with *warn-if-redefine-kernel* set to nil.
  39.  
  40. (in-package :ccl)
  41.  
  42. (export '(with-suspended-appleevent get-appleevent-suspension-ref unsuspend-appleevent
  43.           suspended-appleevent-p resume-and-send-appleevent dispose-suspended-appleevent
  44.           clear-suspended-appleevent))
  45.  
  46. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  47. ;;
  48. ;; suspend-appleevent & resume-and-send-applevent code
  49. ;;
  50. (defvar *suspended-appleevents* nil)
  51. (defvar *handling-incoming-event* nil)
  52.  
  53. ; Useful macro for using previously-suspended events and replies.
  54. ;
  55. (defmacro with-suspended-appleevent ((refcon event reply) &body body)
  56.   (let ((item (gensym)))
  57.     `(let ((,event nil)
  58.            (,reply nil))
  59.        (let ((,item (find ,refcon *suspended-appleevents* :test #'= :key #'(lambda (x) (%ptr-to-int (car x))))))
  60.          (if ,item
  61.            (setq ,event (car ,item)
  62.                  ,reply (cdr ,item)))
  63.          ,@body))))
  64.  
  65. ; Function returns the Apple Event's "reference number" -- store this number somewhere so you can retrieve the
  66. ; event and reply later.
  67. ;
  68. (defun get-appleevent-suspension-ref (event)
  69.   (%ptr-to-int event))
  70.  
  71. ; Function simply removes the AppleEvent and reply from *suspended-appleevents*; it does *not* unsuspend the event.
  72. ;
  73. (defun unsuspend-appleevent (refcon)
  74.   (let ((item (find refcon *suspended-appleevents* :test #'= :key #'(lambda (x) (%ptr-to-int (car x))))))
  75.     (when item
  76.       (#_DisposePtr (car item))
  77.       (#_DisposePtr (cdr item))
  78.       (setf *suspended-appleevents* (delete refcon *suspended-appleevents*
  79.                                             :test #'=
  80.                                             :key #'(lambda (x) (%ptr-to-int (car x)))))
  81.       (free-cons item))))
  82.  
  83. (defun suspended-appleevent-p (refcon)
  84.   (if (find refcon *suspended-appleevents* :test #'= :key #'(lambda (x) (%ptr-to-int (car x))))
  85.     t
  86.     nil))
  87.   
  88. ; Given a reference this event unsuspends an event, sends the reply and clears the event off the
  89. ; hash table.
  90. ;
  91. (defun resume-and-send-appleevent (refcon)
  92.   (let ((item (find refcon *suspended-appleevents* :test #'= :key #'(lambda (x) (%ptr-to-int (car x))))))
  93.     (when item
  94.       (#_AESetTheCurrentEvent (car item))
  95.       (#_AEResumeTheCurrentEvent (car item) (cdr item) (%int-to-ptr #$kAENoDispatch) 0)))
  96.   (unsuspend-appleevent refcon)
  97.   t)
  98.  
  99. ; Function completely disposes of a suspended AppleEvent, given its reference.
  100. ;
  101. (defun dispose-suspended-appleevent (refcon)
  102.   (let ((item (find refcon *suspended-appleevents* :test #'= :key #'(lambda (x) (%ptr-to-int (car x))))))
  103.     (when item
  104.       (without-interrupts
  105.        (#_AEDisposeDesc (car item))
  106.        (#_AEDisposeDesc (cdr item))
  107.        (unsuspend-appleevent refcon))))
  108.   t)
  109.  
  110. ; Clean up of all suspended AppleEvents
  111. ;
  112. (defun clear-suspended-appleevents ()
  113.   (loop while *suspended-appleevents*
  114.         do (dispose-suspended-appleevent (%ptr-to-int (caar *suspended-appleevents*))))
  115.   (setq *suspended-appleevents* nil))
  116.  
  117. (pushnew #'clear-suspended-appleevents *lisp-cleanup-functions* :key #'function-name)
  118.  
  119. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  120. ;;
  121. ;; mods to highlevel-events module
  122. ;;
  123.      
  124. ; Added *handling-incoming-event* setting to ensure that a subsequent call to #'do-deferred-appleevents
  125. ; doesn't tromp all over this call.  I'm not sure if it's really needed, though.
  126. ;
  127. (defpascal defer-appleevent-handler (:pointer theAppleEvent :pointer reply
  128.                                               :long handlerRefcon :word)
  129.   (declare (ignore handlerRefcon))
  130.   (let ((result #$noErr)
  131.         (*handling-incoming-event* t))
  132.     (rlet ((source :word)
  133.            (actualType :long)
  134.            (actualSize :long))
  135.       (if (or *inside-aesend*
  136.               (and (eql #$noErr (#_AEGetAttributePtr theAppleEvent #$keyEventSourceAttr
  137.                                  #$TypeShortInteger actualType source 2 actualSize))
  138.                    (or (eql #$kAESameProcess (%get-word source))
  139.                        (eql #$kAEDirectCall (%get-word source)))))
  140.         (setf result (do-appleevent theAppleEvent reply nil))
  141.         (progn
  142.           (ae-error (#_AESuspendTheCurrentEvent theAppleEvent))
  143.           (setq *deferred-appleevents* (nconc *deferred-appleevents*
  144.                                               (cheap-cons (cheap-cons (copy-record theAppleEvent :AEDesc)
  145.                                                                       (copy-record reply :AEDesc))
  146.                                                           nil))))))
  147.     result))
  148.  
  149. ; Function now processes only the first queued AppleEvent during its call instead of the whole list.
  150. ; This is a better resource-management scheme for some operations, particularly for servers.
  151. ; 
  152. (defun do-deferred-appleevents ()
  153.   (when (and *deferred-appleevents*
  154.              (not *doing-deferred-appleevents*)
  155.              (not *handling-incoming-event*))
  156.     (setq *doing-deferred-appleevents* t)
  157.     (unwind-protect
  158.       (let* ((event-info (pop-and-free *deferred-appleevents*))
  159.              (theAppleEvent (car (the list event-info)))
  160.              (reply (cdr (the list event-info))))
  161.         (if (eql :suspend (do-appleevent theAppleEvent reply t))
  162.           (setq *suspended-appleevents* (nconc *suspended-appleevents*
  163.                                                (cheap-cons (cheap-cons theAppleEvent reply)
  164.                                                            nil))))
  165.         (free-cons event-info))
  166.       (setq *doing-deferred-appleevents* nil))))
  167.  
  168. ; The the Lisp handler is now expected to return :suspend value if the event was suspended with
  169. ; #'suspend-appleevent; if this value is found then the event and reply records are *not* disposed.
  170. ; Also, install a #$keyErrorNumber parameter after the Lisp handler only if there is not value already
  171. ; present in the reply.
  172. ;
  173. (defun do-appleevent (theAppleEvent reply deferred-p)
  174.   (let ((result #$noErr)
  175.         (handler-result nil)
  176.         (class nil)
  177.         (id nil))
  178.     (block buck-stops-here
  179.       (unwind-protect      ; don't let anyone throw past me!!                 
  180.         (handler-case
  181.           (flet ((no-handler ()
  182.                    (error (make-condition 'appleevent-error :oserr #$errAEEventNotHandled
  183.                                           :error-string (format nil "No Lisp Handler for '~a' '~a'"
  184.                                                                 class id)))))
  185.             (setq class (ae-get-attribute-type theAppleEvent #$keyEventClassAttr)
  186.                   id (ae-get-attribute-type theAppleEvent #$keyEventIDAttr))
  187.             (let ((id-table (gethash class %appleevent-handlers%)))
  188.               (unless id-table
  189.                 (setq id-table (gethash :|****| %appleevent-handlers%))
  190.                 (unless id-table (no-handler)))
  191.               (let ((handler (gethash id id-table)))
  192.                 (unless handler
  193.                   (no-handler))
  194.                 (setf handler-result (funcall (car handler) *application* theAppleEvent reply (cdr handler))))))
  195.           (error (c)
  196.                  (when *report-appleevent-errors*
  197.                    (format *error-output* "~%> Error while handling AppleEvent: '~a' '~a'~%> "
  198.                            class id)
  199.                    (report-condition c *error-output*))
  200.                  ; try to put the error string in the reply (the reply may be null)
  201.                  ; if the event is itself a reply!
  202.                  (ae-put-parameter-char theAppleEvent #$keyErrorString
  203.                                         (with-output-to-string (s)
  204.                                           (report-condition c s))
  205.                                         nil)
  206.                  (if (typep c 'appleevent-error)
  207.                    (setq result (oserr c))    ; return the error to the AppleEvent Manager
  208.                    (setq result #$errAEEventNotHandled))))
  209.         (return-from buck-stops-here)))
  210.     ; try to put the result code in the reply (the reply may be null)
  211.     ; if the event is itself a reply!
  212.     (unless (or (eql handler-result :suspend)
  213.                 (ae-get-parameter-longinteger reply #$keyErrorNumber nil)
  214.                 (neq result #$noErr))
  215.       (ae-put-parameter-longinteger reply #$keyErrorNumber result nil))
  216.     (when deferred-p
  217.       (unless (eql handler-result :suspend)
  218.         (#_AESetTheCurrentEvent theAppleEvent)
  219.         (#_AEResumeTheCurrentEvent theAppleEvent reply (%int-to-ptr #$kAENoDispatch) 0)
  220.         (#_DisposePtr theAppleEvent)
  221.         (#_DisposePtr reply))
  222.       (when *appleevent-quit*
  223.         (setq *appleevent-quit* nil)          ; don't repeat if aborted out
  224.         (quit)))
  225.     (if (eql handler-result :suspend)
  226.       handler-result
  227.       result)))
  228.  
  229. #|
  230.  
  231. ; Example of handler that suspends event and replies later.  Send the test Apple Event to MCL
  232. ; using HyperCard 2.1 or later with the "ask program" or "answer program" HyperTalk commands.
  233. ; HyperCard should send a Lisp expression -- eg, "(* 9 3)" -- for evaluation.
  234.  
  235. (defmethod suspended-eval-handler ((a application) event reply refcon)
  236.   (declare (ignore reply refcon))
  237.   (let ((ae-ref (get-appleevent-suspension-ref event)))
  238.     (eval-enqueue (list 'handle-suspended-event ae-ref)))       ; Can't do this without the suspend code!
  239.   :suspend)
  240.  
  241. (defun handle-suspended-event (ae-ref)
  242.   (with-suspended-appleevent (ae-ref event reply)
  243.     (let ((what (ignore-errors (ccl::ae-get-parameter-char event #$keyDirectObject nil))))
  244.       (if what
  245.         (ccl::ae-put-parameter-char reply #$keyDirectObject (write-to-string (eval (read-from-string what)))))))
  246.   (resume-and-send-appleevent ae-ref))
  247.  
  248. (install-appleevent-handler :|misc| :|dosc| #'suspended-eval-handler)
  249. (install-appleevent-handler :|misc| :|eval| #'suspended-eval-handler)
  250.  
  251. |#